home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / port.t < prev    next >
Text File  |  1988-05-02  |  4KB  |  117 lines
  1. (herald port
  2.         (env tsys (osys buffer)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Given the filename of a local file, return a port for it.
  28.  
  29. ;;; old   - '( in | out | append)
  30. ;;; major - in | out | append | update
  31. ;;;         '(major . [minor ...])
  32.  
  33. (define (read-objects-from-string string)
  34.   (let ((iob (string->buffer string)))
  35.     (iterate loop ((l '()))
  36.       (let ((obj (read iob)))
  37.         (cond ((eof? obj)
  38.                (release %buffer-pool iob)
  39.                (reverse! l))
  40.               (else
  41.                (loop (cons obj l))))))))
  42.  
  43. ;;; Hack for LOAD-TRANSDUCE.
  44.  
  45. (define (cons-port obj port)
  46.   (let ((flag nil))
  47.     (join (object nil
  48.             ((read self)
  49.              (cond (flag (read port))
  50.                    (else (let ((val obj))
  51.                            (set flag t)
  52.                            (set obj nil)
  53.                            val)))))
  54.           port)))
  55.  
  56. ;++ make this handle PORT-POSITION
  57. (define (make-output-width-port)
  58.   (let ((count 0))
  59.     (object nil
  60.       ((write-char self c)
  61.        (ignore c)
  62.        (set count (fx+ count 1)))
  63.       ((close self) count)               ;++ pretty random
  64.       ((output-width-port? self) '#t)
  65.       ((output-port? self) '#t)
  66.       ((port? self) '#t)
  67.       ((print-type-string self) "Output-port"))))
  68.  
  69. (define (make-broadcast-port . ports)
  70.   (labels (((doit proc)
  71.             (iterate loop ((s ports))
  72.               (cond ((null? s) (no-value))
  73.                     (else
  74.                      (proc (car s))
  75.                      (loop (cdr s))))))
  76.            (port (object nil
  77.                    ((write-char self c)
  78.                     (doit (lambda (port) (write-char port c))))
  79.                    ((hpos self) (hpos (car ports)))
  80.                    ((set-hpos self pos)
  81.                     (doit (lambda (port) (set (hpos port) pos))))
  82.                    ((newline self)
  83.                     (doit newline))
  84.                    ((fresh-line self)
  85.                     (doit fresh-line))
  86.                    ((force-output self)
  87.                     (doit force-output))
  88.                    ((print-type-string self) "Broadcast-port")
  89.                    ((output-port? self) t)
  90.                    ((port? self) t))))
  91.     port))
  92.  
  93. ;;; This is kind of yicky also.
  94.  
  95. (define (make-echo-port iport oport)
  96.   (join (object nil
  97.           ((read-char self)
  98.            (let ((c (read-char iport)))
  99.              (write-char oport c)
  100.              c)))
  101.         iport))
  102.  
  103. ; random utility used by crawl, debug, eval
  104.  
  105. (define (print-one-line obj port)
  106.   (catch abort
  107.     (print obj
  108.            (object nil
  109.              ((writec self char) (writec port char))
  110.              ((writes self string) (writes port string))
  111.              ((hpos self) (hpos port))
  112.              ((port? self) '#t)
  113.              ((newline self)       ; called from space
  114.               (writes self " ---")
  115.               (abort nil)))))
  116.   (no-value))
  117.